#!/usr/bin/perl
#
#                               dispatch.pl
#
#       Site CGI dispatcher for the democratic Internet jukebox. Handles the web interface
#       and does the bulk of the management of the MPD daemon.
#
#
#       Other important scripts related to dispatch.pl:
#
#       queue_refresh.pl - Polls MPD for the current playlist and crops it or adds random
#       tracks as necessary; drops a storable object in /tmp containing the playlist data
#       used here on the front page.
#
#       gen_db.pl - Utility script for scanning the song directory and building the SQLite
#       database used here.
#
# TODO: Why does it show up as the bot when I request "ikaruga_nex - 虚栄心" ?
BEGIN {
    use CGI::Carp qw( carpout carp);
    open(LOG, ">>", "/var/log/lighttpd/dispatch.log") or
        die("Unable to open log: $!\n");
    carpout(LOG);
}

use warnings;
use strict;

use CGI::Fast qw(:standard);
use Audio::MPD;
use File::Slurp;
use URI::Escape;
use DBI;
use Encode;
use File::Basename;
use Ogg::Vorbis::Header::PurePerl;
use MP3::Tag;
use Digest;
use Template;
use Storable;
use HTML::Scrubber;

binmode STDIN,  ":encoding(utf-8)";
binmode STDOUT, ":encoding(utf-8)";
$CGI::POST_MAX = 125 * 1024 * 1024; # No files bigger than 125MB.

my $TARGET_DB = "/home/o0/jpsr/song_db.sqlite";
our $dbh = DBI->connect ("dbi:SQLite:dbname=$TARGET_DB", "", "", {RaiseError => 1})
    or die $DBI::errstr;
our $template = Template->new({ ENCODING => 'utf8', 
                                INCLUDE_PATH => "/home/o0/jpsr/template",
                                PRE_CHOMP => 2,
                                POST_CHOMP => 2,
                                TRIM => 1,
                                STRICT => 1 });
our $QUEUE_MAX = 10;
our $QUEUE = "/tmp/current_playlist_status.storable";
our $MUSIC_DIR = '/home/o0/mpd/music';
our $INCOMING_MUSIC_DIR = '/home/o0/mpd/music/incoming';
our $TEMPLATE_DIR = '/home/o0/jpsr/static';
our $GEN_DB = "/home/o0/jpsr/gen_db.pl";
our $USER_ICONS_PATH = "/home/o0/jpsr/static/user_icons";
our $VERBOSE = 1;
our $TRACK_LENGTH_FLOOR = 10;
our $PORT = 9999;
our $MAX_DEDICATION_LENGTH = 300;
our @user_icons = map { s/.*\/(.*)$/$1/; "user_icons/$1" } <$USER_ICONS_PATH/*>;

# Users' requests  will be declined if they have requested more than
# $REQUEST_CEILING_NUMBER tracks within the last $REQUEST_CEILING_INTERVAL
# seconds.
our $REQUEST_CEILING_INTERVAL = 10 * 60;
our $REQUEST_CEILING_NUMBER   = 3;

our $mpd = Audio::MPD->new;
our $current_song_id = -99999;

# All of this stuff is in separate hashes because I find Perl's system of indirection
# and references unpleasant to deal with, and this is a small project. I know this is
# not proper form. Live with it.
our %requesters = ();   # Store times of last requests per each user.
our %votes = ();        # Map user IPs to upvotes or downvotes for current song.
our %icon_assoc = ();   # Map user IPs to playlist icons. 
our %pl_req = ();       # Map playlist song path to hash ref of requesters' IPs and dedications.

#*******************************************************************************
# Pages to be built.
#*******************************************************************************

sub front {
    # Clear old votes if this is a new track
    my $mpd_id = $mpd->current->id;
    my ($icon, $ded) = ('', '');
    if ($mpd_id != $current_song_id) {
        %votes = ();
        $current_song_id = $mpd_id;
    }
    my %updown = (up => 0, down => 0);
    $updown{ $votes{$_} }++ for keys %votes;
    my $front = retrieve($QUEUE);
    $front->{updown} = \%updown;
    ($front->{pl}, $icon, $ded) = pl_icons($front->{pl});
    $ded = '' unless defined $ded;
    template('front.tmpl', { front => $front, ded => $ded, icon => $icon });
}

sub library {
    my $sth = $dbh->prepare("SELECT DISTINCT artist FROM tracks");
    my ($ltr, %library);

    $sth->execute();
    while (my $row = $sth->fetchrow_arrayref) {
        my $name = decode_utf8( $$row[0] );
        $ltr = substr $name, 0, 1; 
        if      ($ltr =~ /\p{Latin}/)           { $ltr = uc $ltr }
        elsif   ($ltr =~ /\d/)                  { $ltr = '0-9'   }
        elsif   ($ltr =~ /\p{Han}/)             { $ltr = '漢字'  }
        elsif   ($ltr =~ /\p{Hira}|\p{Kana}/)   { $ltr = 'かな'  }
        else                                    { $ltr = '• misc'  }
        $ltr = xml_esc(decode_utf8($ltr));
        !defined $library{$ltr} and $library{$ltr} = [];
        push @{ $library{$ltr} },  { name => xml_esc($name), esc => uri_escape_utf8($name) }; 
    }
    template('library.tmpl', { library => \%library });
}

sub request {
    my $song_id = param('song_id');
    my $MUSIC_DIR = '/home/o0/mpd/music/';
    my $user_ip = $ENV{'REMOTE_ADDR'};

    # Check that queue isn't full.
    my $front = retrieve($QUEUE);
    my $no_queued = $front->{num_queued};
    if ($no_queued >= $QUEUE_MAX) {
        template('info.tmpl', { info => "queue_full" });
        return;
    }
    
    my $sth = $dbh->prepare("SELECT path FROM tracks WHERE id=:1"); 
    $sth->execute($song_id);
    my $path = decode_utf8( ${ $sth->fetchrow_arrayref }[0] );

    process_request($path, $user_ip, "Request Complete.");
}

sub amend_request {
    my $user_ip = $ENV{'REMOTE_ADDR'};
    my $icon = param('icon');
    my $path = param('path');
    my $scrubber = HTML::Scrubber->new();
    my $dedication = $scrubber->scrub( decode_utf8(param('dedication')) );
    $dedication = '' if length $dedication > 300;
    $pl_req{$path} = {ip => $user_ip, ded => $dedication};     # Map playlist song path to requesters' IPs.
    $icon_assoc{$user_ip} = $icon if defined $icon;            # Map user IPs to playlist icons. 
    template('info.tmpl', { info => "request_complete" });
}

sub search {
    my %search;
    my $terms = param('search_library');
    if (!$terms) {
        template('warning.tmpl');
        return;
    }

    $search{query} = $terms;
    my $where_clause = "WHERE artist LIKE :1 OR title LIKE :1 OR album LIKE :1 ";
    if (defined param('target') and param('target') eq 'artist') {
        $where_clause = "WHERE artist=:1 ";
    }
    else {
        $terms = "%$terms%";
    }
    my $sth = $dbh->prepare("SELECT id, artist, title, album, length " .
                            "FROM tracks " . $where_clause . 
                            "ORDER BY artist, album, title LIMIT 250");
    $sth->execute("$terms");
    $search{results} = [];
    while (my $row = $sth->fetchrow_arrayref) {
        push @{ $search{results} }, {'id'        => $$row[0],
                                     'artist'    => xml_esc($$row[1]),
                                     'title'     => xml_esc($$row[2]),
                                     'album'     => xml_esc($$row[3]),
                                     'length'    => minsec($$row[4])};
    }
    $search{query} = xml_esc($search{query});
    template('search.tmpl', { search => \%search });
}

sub upload_track {
    my $path = decode_utf8( param('song') );
    my $autoplay = param('autoplay');
    my $user_ip = $ENV{'REMOTE_ADDR'};

    # CGI not returning a file path generally means it went over the size
    # limit specified by $CGI::POST_MAX (or the user didn't select a file).
    if (!$path) {
        template('info.tmpl', { info => "too_big" });
        carp "User attempted to upload $path, rejected by CGI.";
        return;
    }

    # Only ogg and mp3 are accecptable file types.
    my($filename, $directories, $suffix) = fileparse($path, '.ogg', '.OGG', '.mp3', '.MP3');
    $suffix = lc $suffix;
    if (!$suffix) {
        template('info.tmpl', { info => "wrong_type" });
        carp "User attempted to upload $path, wrong filetype";
        return;
    }
    $filename =~ tr/ /_/;
    $filename = "$filename$suffix";

    # Write actual audio file to temp directory.
    my $upload_fh = upload('song');
    my $temp_path = "$INCOMING_MUSIC_DIR/$filename";
    open my $new_track, ">", $temp_path or die "$!";
    binmode $new_track;
    print {$new_track} $_ while <$upload_fh>;
    close $new_track;

    # MD5 digest check to prevent re-uploads of the same track.
    my $digest = Digest->new('MD5');
    $digest->add( read_file($temp_path) );
    my $track_digest = $digest->b64digest;
    my $sth = $dbh->prepare("SELECT id FROM tracks WHERE digest = :1"); 
    $sth->execute($track_digest);
    if (defined $sth->fetchrow_arrayref) {
        unlink $temp_path;
        template('info.tmpl', { info => "collision" });
        carp "User attempted to upload $path, hash collision in DB for: $track_digest";
        return;
    }

    # Fetch tags to get at artist name, add digest
    my $tags = undef;
    $suffix eq '.mp3' and $tags = get_mp3_tags($temp_path);
    $suffix eq '.ogg' and $tags = get_vorbis_tags($temp_path);
    $tags->{digest} = $track_digest;

    # Tracks below the queue refresh rate may cause mpd to stop before
    # a random track can be appended to the end of a playlist.
    if ($tags->{duration} < $TRACK_LENGTH_FLOOR) {
        unlink $temp_path;
        template('info.tmpl', { info => "too_short" });
        carp "User attempted to upload $path, track too short.";
        return;
    }

    # Create a directory for artist if one doesn't exist, move the file
    # there. Remove any harmful or annoying characters from artist name.
    my $artist = $tags->{artist};
    $artist = 'BLANK_ARTIST' if $artist eq '';
    $artist =~ tr/ \//__/;
    my $artist_dir = "$MUSIC_DIR/" . $artist;
    mkdir $artist_dir if ! -e $artist_dir;
    rename $temp_path, "$artist_dir/$filename";
    my ($final_path) = "$artist_dir/$filename" =~ /^$MUSIC_DIR\/(.*)/;
    $final_path .= '_A' if -e $final_path;

    # Store track info in DB and update mpd library
    $tags->{path} = $final_path;
    my $song_id = insert_track($tags);
    system(qq[ mpc update "$final_path" --wait ]);
    
    # Queue song if autoplay checkbox was set.
    if ($autoplay eq 'on') {
        process_request($final_path, $user_ip, "File uploaded. Track has been queued.");
    }
    else {
        template('info.tmpl', { info => "file_uploaded" });
    }
}

sub vote {
    my $verdict = param('verdict');
    my $user_ip = $ENV{'REMOTE_ADDR'};
    my $mpd_id = $mpd->current->id;

    # Clear old votes if this is a new track
    if ($mpd_id != $current_song_id) {
        %votes = {};
        $current_song_id = $mpd_id;
    }

    carp "voting $verdict song $mpd_id";
    if (defined $votes{$user_ip} && $votes{$user_ip} eq $verdict) {
        template('info.tmpl', { info => "dupvote_$verdict" });
        return;
    }
    $votes{$user_ip} = $verdict;

    my $users = users_connected();
    my %updown = (up => 0, down => 0);
    $updown{ $votes{$_} }++ for keys %votes;
    $mpd->next if $updown{down} > $users / 3 && $users > 3;
    template('info.tmpl', { info => "vote_cast" });
}
#*******************************************************************************
# Song upload utility functions.
#*******************************************************************************

sub get_mp3_tags {
    my $mp3 = MP3::Tag->new(shift);
    my $tags = $mp3->autoinfo();
    $tags->{duration} = int $mp3->total_secs();
    return utf8ize($tags);
}

sub get_vorbis_tags {
    my $ogg = Ogg::Vorbis::Header::PurePerl->new(shift);
    my $tags = {};

    $tags->{artist}   = $ogg->comment('artist');
    $tags->{title}    = $ogg->comment('title');
    $tags->{album}    = $ogg->comment('album');
    $tags->{duration} = $ogg->info->{length};
    return utf8ize($tags);
}

sub insert_track {
    my $t = shift;
    my $sth = $dbh->prepare("INSERT OR IGNORE INTO tracks (artist, title, album, length, path, digest) " .
                            "VALUES (:1, :2, :3, :4, :5, :6);");
    $sth->execute($t->{artist}, $t->{title}, $t->{album}, $t->{duration}, $t->{path}, $t->{digest}); 
    $sth->finish;

    $sth = $dbh->prepare("SELECT last_insert_rowid();"); 
    $sth->execute();
    my $id = ${ $sth->fetchrow_arrayref }[0];
    return $id;
}

sub utf8ize {
    my %tags = %{ $_[0] };
    for my $k ( keys %tags ) {
        $tags{$k} = decode_utf8($tags{$k}); 
    }
    return \%tags;

}

sub xml_esc {
    my $_ = shift;
    s/&/&amp;/g;
    s/</&lt;/g;
    s/>/&gt;/g;
    s/"/&quot;/g;
    s/'/&apos;/g;
    return $_;
}

#*******************************************************************************
# Other stuff
#*******************************************************************************

# Enforce ceiling on requests.
sub verify_request_ceiling {
    my $user_ip = shift;
    my $now = time;
    if (!defined $requesters{$user_ip}) {
        $requesters{$user_ip} = [$now];
        carp "$user_ip undefined in verify_request_ceiling()";
        return 1;
    }

    my @requests = @{ $requesters{$user_ip} };
    if (scalar @requests < $REQUEST_CEILING_NUMBER) {
        push @{ $requesters{$user_ip} }, $now;
        carp "$user_ip present in verify_request_ceiling(), below ceiling. requests: " . scalar @requests;
        return 1;
    }

    my $bottom = $requests[scalar @requests - $REQUEST_CEILING_NUMBER];
    my $time_diff = $now - $bottom;
    carp "$user_ip| \$now: $now |\$time_diff: $time_diff |\$bottom $bottom";
    if ($time_diff < $REQUEST_CEILING_INTERVAL) {
        carp "$user_ip exceeded request ceiling.";
        return 0;
    }
    push @{ $requesters{$user_ip} }, $now;
    carp "$user_ip present in verify_request_ceiling(), above ceiling. requests: " . scalar @requests;
    return 1;
}

sub process_request {
    my ($path, $user_ip, $h1) = @_;
    if (defined $pl_req{$path}) {
        template('info.tmpl', { info => "in_playlist" });
        return;
    }

    if (!verify_request_ceiling($user_ip)) {
        template('info.tmpl', { info => "request_max" });
        return;
    }

    # Audio::MPD module seems incapable of dealing with Unicode when adding 
    # new tracks; throws up spurious file not found errors while ASCII-named
    # files in the same directory are fine. So mpc is being invoked directly
    # to add tracks.
    system(qq[ mpc add "$path"]);
    $icon_assoc{$user_ip} = "user_icons/anon.png" unless defined $icon_assoc{$user_ip};
    $pl_req{$path} = {ip => $user_ip, ded => ''};     # Map playlist song path to requesters' IPs.

    template('request_complete.tmpl', { path => xml_esc($path) , user_icons => \@user_icons, h1 => $h1});
    carp $user_ip . " requested " . $path;
}

sub minsec {
    return int($_[0] / 60) . ':' . sprintf("%02d", ($_[0] % 60));
}

sub users_connected {
    my @users_connected = `netstat -aln | grep :$PORT | grep 'ESTABLISHED'`;

    # Ignores additional entries for users with multiple ports held open.
    my %users = ();
    for (@users_connected) {
        my $ip = (split ':', (split[4]))[0];
        $users{$ip} = 1; 
    }
    my $count = 0;
    $count++ for keys %users;
    return $count;
}

# Associate user icons with playlist on front page
sub pl_icons {
    my $pl =  shift;
    my %new_pl_req = (); # This will replace the old %pl_req, clearing out old entries.
    my ($ip, $icon, $cur_icon, $ded);
    for my $t (@$pl) {
        my $req = $pl_req{ $t->{path} };
        if (!defined ($ip = $req->{ip}) ) {
            $t->{icon} = 'admin_icons/bot.png';
            next;
        }

        if (!defined ($icon = $icon_assoc{$ip}) ) {
            $t->{icon} = 'user_icons/anon.png';
        }
        else {
            $t->{icon} = "$icon";
        }

        if ($t->{pos} eq "current") {
            $cur_icon = $t->{icon};
            $ded = $req->{ded};
        }
        $new_pl_req{ $t->{path} } = { ip => $ip, ded => $req->{ded} };
    }
    %pl_req = %new_pl_req;
    return ($pl, $cur_icon, $ded);
}

sub template {
    my ($tmpl, $param) = @_;
    $template->process($tmpl, $param) or die $template->error(), "\n";
}
#*******************************************************************************
# Main.
#*******************************************************************************

my $requested_page;
my %pages = (
    '/'              => \&front,
    '/amend_request' => \&amend_request,
    '/library'       => \&library,
    '/request'       => \&request,
    '/search'        => \&search,
    '/upload_track'  => \&upload_track,
    '/vote'          => \&vote,
);

while (new CGI::Fast) {
    $requested_page = url(-absolute => 1);
    if (defined $pages{$requested_page}) {
        print header(-type => 'application/xhtml+xml', -charset => 'utf-8');
        $pages{$requested_page}->();
    }
    else {
        print header('text/xhtml','404 Not Found');
    }
}

